home *** CD-ROM | disk | FTP | other *** search
/ Resource Library: Multimedia / Resource Library: Multimedia.iso / archvrs / msdos / tpli_10 / tpl1.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-10-13  |  25.6 KB  |  998 lines
  1.  
  2.  
  3. /*
  4.  * TPL1 - Threaded Programming Language / I
  5.  *
  6.  * Copyright 1983, 1989 Samuel H. Smith;  All rights reserved
  7.  *
  8.  *    Do not distribute modified versions without my permission.
  9.  *    Do not remove or alter this notice or any other copyright notice.
  10.  *    If you use this in your own program you must distribute source code.
  11.  *    Do not use any of this in a commercial product.
  12.  *
  13.  * Created: 10-21-83 SHS
  14.  *
  15.  */
  16.  
  17.  
  18. #include <stdio.h>
  19. #include <ctype.h>
  20.  
  21. #define repeat for(;;)
  22.  
  23.  
  24.  
  25. /* definition of first-in last-out stack */
  26.  
  27. struct stack {                          /* A Stack Structure */
  28.         int  s_ptr;                     /* Stack Pointer */
  29.         int  s_size;                    /* Size Of The Stack */
  30.         int  *s_data;                   /* The Data On The Stack */
  31. };
  32.  
  33. struct stack _data;                     /* Data Stack */
  34. struct stack _control;                  /* Control Stack */
  35.  
  36.  
  37.  
  38. /* definitions of plist types */
  39.  
  40. #define D_INT      0            /* a primitive interpreted in compile mode */
  41. #define D_COMP     1            /* a primitive called in compile mode */
  42. #define D_LAYERED  127          /* a layered non-primitive word */
  43.  
  44. struct plist {                          /* A Primitive-list Structure */
  45.         char   *pl_name;                /* Name Of This List */
  46.         char   pl_type;                 /* Type Of Plist 0=primitive */
  47.         struct plist **pl_funs;         /* Table of sub-lists or a pointer to
  48.                                            the single called by this list */
  49. };
  50.  
  51. typedef struct plist plist;
  52.  
  53. #define PRIM plist **                /* use (PRIM) prefix in dictionary */
  54.  
  55. typedef int (*funptr)();
  56. #define FUNPTR funptr           /* use (FUNPTR) prefix to convert
  57.                        sub-plists into function ptrs */
  58.  
  59. struct plist **curint;                  /* Current Interpreter Word Position */
  60.  
  61. int    compile;                         /* Compile Mode Flag */
  62. struct plist *defplt[250];              /* Current DEFINE Pointer List */
  63. int    defcnt;                          /* Current DEFINE Pointer Count */
  64. int    errors;                          /* error count in DEFINE */
  65.  
  66. FILE * infd = stdin;                    /* Current Input File */
  67. char   linebuf[200];                    /* Current Input Line */
  68. int    linepos;                         /* Position In Input Line */
  69. char   wordbuf[100];                    /* Current Input Word */
  70. char   tmpword[100];                    /* Temp buffer for QUOTE primitive */
  71.  
  72. char   *lastmem;                        /* Last allocated addr for FREEMEM */
  73.  
  74. #define DICTSIZE  500                   /* Maximum Size Of The Dictionary */
  75. int    dictsize;                        /* Current Size Of The Dictionary */
  76.  
  77. struct plist    *ifpl,                  /* pl address for "if" function */
  78.                 *elsepl,                /*                "else"        */
  79.                 *endifpl,               /*                "endif"       */
  80.                 *dopl,                  /*                "do"          */
  81.                 *whilepl,               /*                "while"       */
  82.                 *untilpl,               /*                "until"       */
  83.                 *litpl;                 /*                "<lit>"       */
  84.  
  85. struct plist *pl_init();
  86. struct plist *pl_find();
  87. char *strsave();
  88. char *memalloc();
  89.  
  90.  
  91. main()
  92. {
  93.         extern struct plist dict[];
  94.  
  95.         printf("\nTPL1 - Threaded Programming Language / I   Copyright 1989 Samuel H. Smith\n");
  96.  
  97.         stk_init(&_data,200);                   /* Allocate Data Stack */
  98.         stk_init(&_control,100);                /* Allocate Control Stack */
  99.  
  100.         dictsize = 0;
  101.         while (dict[++dictsize].pl_name);       /* Find end of dictionary */
  102.  
  103.         ifpl    = pl_find("IF");                /* init some pl pointers */
  104.         elsepl  = pl_find("ELSE");
  105.         endifpl = pl_find("ENDIF");
  106.         dopl    = pl_find("DO");
  107.         whilepl = pl_find("WHILE");
  108.         untilpl = pl_find("UNTIL");
  109.         litpl   = pl_find("<LIT>");
  110.  
  111.  
  112.         infd = fopen("tpl1dic.tpl","r");        /* Open standard dic file */
  113.         if (infd <= 0) {
  114.                 printf("Can't open tpl1dic.tpl\n");
  115.                 infd = stdin;
  116.         }
  117.  
  118.         while (interactive());                  /* Do interactive input */
  119.  
  120.         exit(0);
  121. }
  122.  
  123.  
  124. interactive()           /* Do a line of Interactive User-interface */
  125. {
  126.         struct plist *pl;
  127.  
  128.         if (infd == stdin) {
  129.                 printf("\nok\n");       /* prompt stdin reads */
  130.         }
  131.  
  132.         if (!getline())
  133.                 return 0;               /* end of stdin file? */
  134.  
  135.         while (getword()) {
  136.                 if (wordbuf[0] == 0)    /* skip blank words */
  137.                         continue;       
  138.  
  139.                 pl = pl_find(wordbuf);  /* Find And Execute It */
  140.                 if (pl == 0) {
  141.                         if (isdigit(wordbuf[0])) {
  142.                                 /* Push Literal Numbers */
  143.                                 stk_push(&_data,atoi(wordbuf));  
  144.                         }  
  145.                         else {
  146.                                 printf("'%s' is undefined.\n",wordbuf);
  147.                         }
  148.                 }
  149.                 else pl_interp(pl);     /* Else Interpret The Word */
  150.         }
  151.  
  152.         return 1;
  153. }
  154.  
  155.  
  156.  
  157. /*
  158.  * Pl_init - Initialize A New Primitive-list
  159.  *
  160.  */
  161.  
  162. struct plist *
  163. pl_init(name,size)
  164. char *name;             /* Name Of The Plist To Create */
  165. int  size;              /* Number Of Functions In The Plist */
  166. {
  167.         struct plist *pl;
  168.  
  169.         if (dictsize >= DICTSIZE) {
  170.                 printf("Dictionary is full\n");
  171.                 errors++;
  172.                 dictsize--;                     /* Re-define last entry */
  173.         }
  174.  
  175.         pl = &dict[dictsize++];                 /* Find New Dict Entry */
  176.     pl->pl_funs = (PRIM)memalloc(sizeof(pl) * size);
  177.                         /* Alloc The Plist Array */
  178.  
  179.         stoupper(name);                         /* Make names upper case */
  180.         pl->pl_name = strsave(name);            /* Save the Plist name */
  181.         pl->pl_type = D_LAYERED;                /* A Non-primitive Plist */
  182.  
  183.         return pl;                              /* Pointer To The New Plist */
  184. }
  185.  
  186.  
  187.  
  188. /*
  189.  * pl_find - find a dictionary entry by name.  returns
  190.  *           address of the located pl entry, 0 if not found
  191.  */
  192.  
  193. struct plist *
  194. pl_find(str)            /* Find A Dictionary Entry By Keyword */
  195. char *str;
  196. {
  197.         int  i;
  198.  
  199.         stoupper(str);          /* all words are uppercase */
  200.  
  201.         /* search backwards to make new definitions faster */
  202.  
  203.         for (i = dictsize-1; i >= 0; i--)
  204.         {
  205.                 if (strcmp(dict[i].pl_name,str) == 0)
  206.                         return &dict[i];
  207.         }
  208.  
  209.         return 0;               /* Not Found */
  210. }
  211.  
  212.  
  213.  
  214. /*
  215.  * Plist Interpreter -  Recursively Interprets A Plist, Returns
  216.  *                      Number Of Data Slots To Skip
  217.  *
  218.  */
  219.  
  220. pl_interp(pl)
  221. register struct plist *pl;      /* Pointer To Plist To Be Interpreted */
  222. {
  223.         register struct plist *subpl;
  224.         register struct plist **prvint;
  225.         int (*fun)();
  226.  
  227.  
  228.         /* call it directly if it is one of the primitive types */
  229.  
  230.         if (pl->pl_type != D_LAYERED) {         /* Is This A Primitive? */
  231.         fun = (FUNPTR)pl->pl_funs;      /* Then Run It Directly */
  232.                 (*fun)();
  233.                 return;
  234.         }
  235.  
  236.  
  237.         /* It Is Not A Primitive */
  238.  
  239.         prvint  = curint;               /* Save Previous Interp Posit */
  240.         curint  = pl->pl_funs;
  241.  
  242.         repeat {                                /* Interpret Each Function */
  243.                 subpl = *curint++;              /* As A Sub-plist */
  244.                 if (subpl == 0) break;
  245.                 pl_interp(subpl);
  246.         }
  247.  
  248.         curint  = prvint;                       /* Restore Interp Position */
  249. }
  250.  
  251.  
  252. stk_init(stack,size)            /* Initialize New Stack */
  253. struct stack *stack;
  254. int  size;
  255. {
  256.     stack->s_data = (int *)memalloc(size * sizeof(int));
  257.         stack->s_size = size;
  258.         stack->s_ptr  = 0;
  259. }
  260.  
  261.  
  262. stk_push(stack,data)            /* Push Data On The Stack */
  263. struct stack *stack;
  264. int data;
  265. {
  266.         if (stack->s_ptr >= stack->s_size) {
  267.                 printf("Stack full\n");
  268.                 return;
  269.         }
  270.         stack->s_data[stack->s_ptr++] = data;
  271. }
  272.  
  273.  
  274. stk_pop(stack)                  /* Pop Data From Top Of Stack */
  275. struct stack *stack;
  276. {
  277.         if (stack->s_ptr == 0) {
  278.                 printf("Empty stack\n");
  279.         return 0;
  280.         }
  281.         return stack->s_data[--stack->s_ptr];
  282. }
  283.  
  284.  
  285. stk_top(stack)                  /* Get Data At Top Of Stack */
  286. struct stack *stack;
  287. {
  288.         if (stack->s_ptr == 0) {
  289.                 printf("Empty stack\n");
  290.         return 0;
  291.         }
  292.         return stack->s_data[stack->s_ptr-1];
  293. }
  294.  
  295.  
  296. stk_empty(stack)                /* See If Stack Is Empty */
  297. struct stack *stack;
  298. {
  299.         if (stack->s_ptr == 0)
  300.                 return 1;
  301.         else
  302.                 return 0;
  303. }
  304.  
  305.  
  306. getline()               /* Get A Line Of User Input */
  307. {                       /* return 0 on end of file */
  308.         int  i;
  309.         int  c;
  310.  
  311.         fflush(stdout);
  312.         i = 0;
  313.         repeat {
  314.                 c = fgetc(infd);
  315.                 if (c == EOF) {
  316.                         if (infd == stdin)
  317.                                 return 0;       /* eof in stdin? */
  318.  
  319.                         fclose(infd);           /* else go back to stdin */
  320.                         infd = stdin;
  321.                         break;
  322.                 }
  323.                 if (c == '\n') break;
  324.  
  325.                 linebuf[i++] = c;
  326.         }
  327.  
  328.         linebuf[i] = 0;
  329.         linepos = 0;
  330.         return 1;
  331. }
  332.  
  333.  
  334. getword()       /* Get A Word From Current Line, Return 0 End Of Line */
  335. {               /* return 0 on end of line */
  336.         char c;
  337.         int  i;
  338.  
  339.         fflush(stdout);
  340.  
  341.         if (linebuf[linepos] == 0)
  342.                 return 0;      /* End Of Line? */
  343.  
  344.         i = 0;
  345.         repeat {
  346.                 c = linebuf[linepos];
  347.                 if (c == 0) break;
  348.                 linepos++;
  349.                 if (isspace(c)) break;
  350.  
  351.                 wordbuf[i++] = c;
  352.         }
  353.         
  354.         wordbuf[i] = 0;
  355.  
  356.         return 1;
  357. }
  358.  
  359.  
  360. nextword()              /* Get Next Word From User Input */
  361. {                       /* return 0 on end of file */
  362.         repeat {
  363.                 while (getword() == 0) {
  364.                         if (getline() == 0)
  365.                                 return 0;       /* end of file? */
  366.                 }
  367.                 if (wordbuf[0]) break;          /* skip blank words */
  368.         }
  369.         return 1;
  370. }
  371.  
  372.  
  373. char *
  374. strsave(str)            /* Save string and return pointer to it */
  375. char *str;
  376. {
  377.         char *buf;
  378.  
  379.         buf = memalloc(strlen(str)+1);
  380.         strcpy(buf,str);
  381.         return buf;
  382. }
  383.  
  384.  
  385. stoupper(str)           /* map string to upper case */
  386. char *str;
  387. {
  388.         while (*str) {
  389.                 if (islower(*str))
  390.                         *str = toupper(*str);
  391.                 str++;
  392.         }
  393. }
  394.  
  395.  
  396. char *
  397. memalloc(size)          /* allocate memory buffer */
  398. int size;
  399. {
  400.         char *mem;
  401.     mem = (char *)malloc(size);
  402.         if (mem == 0) {
  403.                 printf("Out of memory, size=%d\n",size);
  404.                 errors++;
  405.         }
  406.  
  407.         lastmem = mem + size;           /* save last allocation for FREEMEM */
  408.         return mem;
  409. }
  410.  
  411.  
  412. /*
  413.  *
  414.  * Library of Primitive (core) Functions
  415.  *
  416.  * These are the functions that make up the default (or core) dictionary
  417.  * of TPL1.  The standard dictionary is defined entirely in terms of
  418.  * these primitive functions.
  419.  *
  420.  */
  421.  
  422. /*
  423.  * DEFINE - this is the basic word definition function.  
  424.  *
  425.  * define builds a new dictionary entry with the threaded dictionary
  426.  * entries of the words going into the deinition.  Literal numbers are
  427.  * compiled as "<LIT>" calls.  Primitives of type "1" are called to
  428.  * do their own compiles.  Primitives of type "0" are simple threaded
  429.  * into the definition.
  430.  *
  431.  * syntax:      : NAME   <word> <word> ... <word> ;
  432.  *
  433.  */
  434.  
  435. DEFINE()                /* Define A New Word   : Name ... ;  */
  436. {
  437.         struct plist *pl;
  438.         int  (*fun)();
  439.         char name[40];
  440.         int  j;
  441.  
  442.         if (compile) {
  443.                 printf("Missing ';' or nested define\n");
  444.                 errors++;
  445.         }
  446.  
  447.         nextword();
  448.         strcpy(name,wordbuf);           /* get name of word to define */
  449.         pl = pl_find(wordbuf);
  450.         if (pl != 0) {
  451.                 printf("'%s' redefined.\n",wordbuf);
  452.         }
  453.  
  454.         errors = 0;
  455.         compile = 1;
  456.         defcnt = 0;                     /* flag compile mode */
  457.         repeat {
  458.                 nextword();
  459.                 if (strcmp(wordbuf,";") == 0)
  460.                         break;          /* End Definition? */
  461.  
  462.                 pl = pl_find(wordbuf);
  463.                 if (pl == 0) {
  464.                         if (isdigit(wordbuf[0])) {
  465.                                 defplt[defcnt++] = litpl;
  466.                 defplt[defcnt++] = (plist *)atoi(wordbuf);
  467.                         }
  468.                         else {
  469.                                 printf("'%s' is undefined.\n",wordbuf);
  470.                                 errors++;
  471.                         }
  472.                 }
  473.                 else {
  474.                         if (pl->pl_type == D_COMP) {    /* Needs Compile? */
  475.                 fun = (FUNPTR)pl->pl_funs;
  476.                                 (*fun)();               /* then call it */
  477.                         }
  478.                         else {
  479.                                 defplt[defcnt++] = pl;  /* Add The Function */
  480.                         }
  481.                 }
  482.  
  483.                 if (defcnt > 240) {
  484.                         printf("Definition too long\n");
  485.                         errors++;
  486.                 }
  487.         }
  488.  
  489.         defplt[defcnt++] = 0;                   /* Mark End Of List */
  490.         compile = 0;
  491.  
  492.         if (errors) 
  493.                 return;                         /* dont define if errors */
  494.  
  495.         pl = pl_init(name,defcnt);              /* Make The Dictionary Entry */
  496.         for (j = 0; j < defcnt; j++)            /* Copy The Plist Pointers */
  497.                 pl->pl_funs[j] = defplt[j];
  498. }
  499.  
  500.  
  501. LITERAL()               /* Place A Literal Value On The Data Stack */
  502. {
  503.         stk_push(&_data,*curint++);
  504. }
  505.  
  506.  
  507. DROP()                  /* Drop Top Of Stack Value */
  508. {
  509.         stk_pop(&_data);
  510. }
  511.  
  512.  
  513. DUP()                   /* Duplicate Top Of Stack Value */
  514. {
  515.         stk_push(&_data,stk_top(&_data));
  516. }
  517.  
  518.  
  519. SWAP()                  /* Swap Top 2 Stack Values */
  520. {
  521.         int  i,j;
  522.         i = stk_pop(&_data);
  523.         j = stk_pop(&_data);
  524.         stk_push(&_data,i);
  525.         stk_push(&_data,j);
  526. }
  527.  
  528.  
  529. ADD()                   /* Add Top 2 Stack Values */
  530. {
  531.         int  i,j;
  532.         i = stk_pop(&_data);
  533.         j = stk_pop(&_data);
  534.         stk_push(&_data, j+i);
  535. }
  536.  
  537.  
  538. SUBTRACT()              /* Subtract Top 2 Stack Values */
  539. {
  540.         int  i,j;
  541.         i = stk_pop(&_data);
  542.         j = stk_pop(&_data);
  543.         stk_push(&_data, j-i);
  544. }
  545.  
  546.  
  547. MULTIPLY()              /* Multiply Top 2 Stack Values */
  548. {
  549.         int  i,j;
  550.         i = stk_pop(&_data);
  551.         j = stk_pop(&_data);
  552.         stk_push(&_data, j*i);
  553. }
  554.  
  555.  
  556. DIVIDE()                /* Divide Top 2 Stack Values */
  557. {
  558.         int  i,j;
  559.         i = stk_pop(&_data);
  560.         j = stk_pop(&_data);
  561.         stk_push(&_data, j/i);
  562. }
  563.  
  564.  
  565. PUTCHAR()               /* Print  Out Character On Top Of Stack */
  566. {
  567.         putchar(stk_pop(&_data));
  568. }
  569.  
  570.  
  571. PUTINT()                /* Print  Out Integer On Top Of Stack */
  572. {
  573.         printf("%d",stk_pop(&_data));
  574. }
  575.  
  576.  
  577. UPUTINT()               /* Print  Out Unsigned Integer On Top Of Stack */
  578. {
  579.         printf("%u",stk_pop(&_data));
  580. }
  581.  
  582.  
  583. GETCHAR()               /* Get Character To Top Of Stack */
  584. {
  585.         stk_push(&_data,fgetc(infd));
  586. }
  587.  
  588.  
  589. GETINT()                /* Get Integer To Top Of Stack */
  590. {
  591.         int  i = 0;
  592.         nextword();
  593.         i = atoi(wordbuf);
  594.         stk_push(&_data,i);
  595. }
  596.  
  597.  
  598. VARIABLE()              /* VARIABLE name - declare integer */
  599. {
  600.         struct plist *pl;
  601.         nextword();
  602.         pl = pl_init(wordbuf,3);
  603.         pl->pl_funs[0] = litpl;
  604.     pl->pl_funs[1] = (plist *)memalloc(sizeof(int));
  605.         pl->pl_funs[2] = 0;
  606. }
  607.  
  608.  
  609. BUFFER()                /* size BUFFER name - declare character buffer */
  610. {
  611.         struct plist *pl;
  612.         nextword();
  613.         pl = pl_init(wordbuf,3);
  614.         pl->pl_funs[0] = litpl;
  615.     pl->pl_funs[1] = (plist *)memalloc(stk_pop(&_data));
  616.         pl->pl_funs[2] = 0;
  617. }
  618.  
  619.  
  620. CONSTANT()              /* value CONSTANT name - declare constant */
  621. {
  622.         struct plist *pl;
  623.         nextword();
  624.         pl = pl_init(wordbuf,3);
  625.         pl->pl_funs[0] = litpl;
  626.     pl->pl_funs[1] = (plist *)stk_pop(&_data);
  627.         pl->pl_funs[2] = 0;
  628. }
  629.  
  630.  
  631. COMMENT()               /* comment to be ignored */
  632. {
  633.         repeat {
  634.                 if (nextword() == 0)
  635.                         break;          /* end of file? */
  636.  
  637.                 if (strcmp(wordbuf,"*/") == 0)
  638.                         break;          /* end of comment? */
  639.         }
  640. }
  641.  
  642.  
  643. PRQUOTE()                               /* Print  Literal String ." ... " */
  644. {
  645.         int  i;
  646.  
  647.         repeat {
  648.                 nextword();
  649.                 if (strcmp(wordbuf,"\"") == 0) break;
  650.                 if (compile) {
  651.                         defplt[defcnt++] = litpl;
  652.             defplt[defcnt++] = (plist *)strsave(wordbuf);
  653.                         defplt[defcnt++] = pl_find("TYPESTR");
  654.                 }
  655.                 else {
  656.                         printf("%s ",wordbuf);
  657.                 }
  658.         }
  659.  
  660. }
  661.  
  662.  
  663. SPACES()                        /* Print  Spaces */
  664. {
  665.         int i;
  666.         i = stk_pop(&_data);
  667.         while (i--)
  668.                 putchar(' ');
  669. }
  670.  
  671.  
  672. NEWLINE()               /* Print  Newline */
  673. {
  674.         putchar('\n');
  675. }
  676.  
  677.  
  678. TYPESTR()               /* Type String Pointed To By Top Of Stack */
  679. {
  680.         printf("%s ",stk_pop(&_data));
  681. }
  682.  
  683.  
  684. QUOTE()                 /* Put address of string on stack */
  685. {
  686.         nextword();
  687.  
  688.         if (compile) {
  689.                 defplt[defcnt++] = litpl;
  690.         defplt[defcnt++] = (plist *)strsave(wordbuf);
  691.         }
  692.         else {
  693.                 strcpy(tmpword,wordbuf);
  694.                 stk_push(&_data,tmpword);
  695.         }
  696. }
  697.  
  698.  
  699. GETSTR()                /* Put address of USER INPUT string on stack */
  700. {
  701.         if (compile) {
  702.                 defplt[defcnt++] = pl_find("\"");
  703.         }
  704.         else {
  705.                 nextword();
  706.                 strcpy(tmpword,wordbuf);
  707.                 stk_push(&_data,tmpword);
  708.         }
  709. }
  710.  
  711.  
  712. LOADFILE()              /* redirect input from QUOTEd string */
  713. {
  714.         char *fn;
  715.  
  716.         if (infd != stdin) {
  717.                 fclose(infd);
  718.                 infd = stdin;
  719.         }
  720.  
  721.     fn = (char *)stk_pop(&_data);
  722.         infd = fopen(fn,"r");
  723.         if (infd <= 0) {
  724.                 printf("Can't read '%s'\n",fn);
  725.                 infd = stdin;
  726.         }
  727. }
  728.  
  729.  
  730. PRDICT()        /* print contents of dictionary */
  731. {
  732.         int i;
  733.         extern struct plist dict[];
  734.  
  735.         for (i=0; i<dictsize; i++) {
  736.                 printf("%13s  ",dict[i].pl_name);
  737.                 if (i%5 == 4)
  738.                         putchar('\n');
  739.         }
  740. }
  741.  
  742.  
  743. FETCH()         /* replace address with integer contents */
  744. {
  745.         int *dat;
  746.     dat = (int *)stk_pop(&_data);
  747.         stk_push(&_data,*dat);
  748. }
  749.  
  750.  
  751. STORE()         /* store tos-1 data at tos address */
  752. {
  753.         int *dat;
  754.     dat = (int *)stk_pop(&_data);
  755.         *dat = stk_pop(&_data);
  756. }
  757.  
  758.  
  759. DO()            /* DO .... t/f UNTIL */
  760. {
  761.         stk_push(&_control,curint);
  762. }
  763.  
  764.  
  765. UNTIL()         /* DO .... t/f UNTIL */
  766. {
  767.         int predicate;
  768.  
  769.         predicate = stk_pop(&_data);
  770.         if (predicate) {
  771.                 stk_pop(&_control);
  772.         }
  773.         else {
  774.         curint = (PRIM)stk_top(&_control);
  775.         }
  776. }
  777.  
  778.  
  779. WHILE()         /* DO .... t/f WHILE */
  780. {
  781.         int predicate;
  782.  
  783.         predicate = stk_pop(&_data);
  784.         if (predicate == 0) {
  785.                 stk_pop(&_control);
  786.         }
  787.         else {
  788.         curint = (PRIM)stk_top(&_control);
  789.         }
  790. }
  791.  
  792.  
  793. CONTINUE()      /* DO .. CONTINUE .. t/f WHILE */
  794. {
  795.     curint = (PRIM)stk_top(&_control);
  796. }
  797.  
  798.  
  799. BREAK()         /* DO ... BREAK ... WHILE */
  800. {
  801.         struct plist *pl;
  802.  
  803.     while ((pl = *curint++) != 0) {
  804.                 if (pl == whilepl) break;
  805.                 if (pl == untilpl) break;
  806.         }
  807.  
  808.         stk_pop(&_control);
  809. }
  810.  
  811.  
  812. DOIF()          /* t/f IF ... [ELSE] ... ENDIF */
  813. {
  814.         int predicate;
  815.         struct plist *pl;
  816.  
  817.         predicate = stk_pop(&_data);
  818.         if (predicate)
  819.                 return;         /* do nothing if true */
  820.  
  821.  
  822.         /* else skip to next ELSE or ENDIF */
  823.  
  824.     while ((pl = *curint++) != 0) {
  825.                 if (pl == elsepl) break;
  826.                 if (pl == endifpl) break;
  827.         }
  828. }
  829.  
  830.  
  831. DOELSE()                /* t/f IF ... ELSE ... ENDIF */
  832. {
  833.         struct plist *pl;
  834.                 
  835.     while ((pl = *curint++) != 0) {
  836.                 if (pl == endifpl) break;
  837.         }
  838. }
  839.  
  840.  
  841.  
  842. ENDIF()                 /* t/f IF ... ENDIF */
  843. {
  844.         /* no op statement */
  845. }
  846.  
  847.  
  848. LESSTHAN()              /* relational operator */
  849. {
  850.         int i,j;
  851.         i = stk_pop(&_data);
  852.         j = stk_pop(&_data);
  853.         stk_push(&_data, j<i);
  854. }
  855.  
  856.  
  857. ULESSTHAN()             /* unsigned lessthan */
  858. {
  859.         unsigned i,j;
  860.         i = stk_pop(&_data);
  861.         j = stk_pop(&_data);
  862.         stk_push(&_data, j<i);
  863. }
  864.  
  865.  
  866. NOT()                   /* replace non-0 with 0 on stack */
  867. {
  868.         stk_push(&_data, ! stk_pop(&_data));
  869. }
  870.  
  871.  
  872. DOEXIT()                /* exit to system */
  873. {
  874.         exit(0);
  875. }
  876.  
  877.  
  878. PLFIND()                /* find a word, replace with pl address */
  879. {
  880.         stk_push(&_data,pl_find(stk_pop(&_data)));
  881. }
  882.  
  883.  
  884. PLPRINT()       /* print definition of a pl pointer */
  885. {
  886.         struct plist *pl,**subpl;
  887.  
  888.     pl = (plist *)stk_pop(&_data);
  889.         if (pl == 0)
  890.                 return;
  891.  
  892.         printf(": %s\t",pl->pl_name);
  893.         if (pl->pl_type != 127) {
  894.                 printf("(primitive) ");
  895.         }
  896.         else {
  897.                 subpl = pl->pl_funs;
  898.                 repeat {
  899.                         pl = *subpl++;
  900.                         if (pl == 0) break;
  901.                         if (pl == litpl) {
  902.                                 printf("%d ",*subpl++);
  903.                         }
  904.                         else {
  905.                                 printf("%s ",pl->pl_name);
  906.                         }
  907.                 }
  908.         }
  909.         printf(";\n");
  910. }
  911.  
  912.  
  913. DTOC()          /* move top of data stack to control stack */
  914. {
  915.         stk_push(&_control,stk_pop(&_data));
  916. }
  917.  
  918.  
  919. CTOD()          /* move top of control stack to data stack */
  920. {
  921.         stk_push(&_data,stk_pop(&_control));
  922. }
  923.  
  924.  
  925. PLSIZE()        /* return size of a plist (dictionary) entry */
  926. {
  927.         stk_push(&_data,sizeof(struct plist));
  928. }
  929.  
  930.  
  931. FREEMEM()       /* return number of bytes of free memory */
  932. {
  933.         char i;         /* this method might not work on all systems */
  934.  
  935.         stk_push(&_data,&i - lastmem);
  936. }
  937.  
  938.         
  939.  
  940. /*
  941.  * Dictionary of Primitive Functions
  942.  *
  943.  */
  944.  
  945. struct plist dict[DICTSIZE] = {
  946.         {"<LIT>",       D_INT,  (PRIM)LITERAL},
  947.         {"(PLFIND)",    D_INT,  (PRIM)PLFIND},
  948.         {"(PLPRINT)",   D_INT,  (PRIM)PLPRINT},
  949.         {"(PLSIZE)",    D_INT,  (PRIM)PLSIZE},
  950.         {"DROP",        D_INT,  (PRIM)DROP},
  951.         {"DUP",         D_INT,  (PRIM)DUP},
  952.         {"SWAP",        D_INT,  (PRIM)SWAP},
  953.         {"D->C",        D_INT,  (PRIM)DTOC},
  954.         {"C->D",        D_INT,  (PRIM)CTOD},
  955.         {"+",           D_INT,  (PRIM)ADD},
  956.         {"-",           D_INT,  (PRIM)SUBTRACT},
  957.         {"*",           D_INT,  (PRIM)MULTIPLY},
  958.         {"/",           D_INT,  (PRIM)DIVIDE},
  959.         {"@",           D_INT,  (PRIM)FETCH},
  960.         {"!",           D_INT,  (PRIM)STORE},
  961.         {"<",           D_INT,  (PRIM)LESSTHAN},
  962.         {"U<",          D_INT,  (PRIM)ULESSTHAN},
  963.         {"/*",          D_COMP, (PRIM)COMMENT},
  964.         {"\"",          D_COMP, (PRIM)QUOTE},
  965.         {".\"",         D_COMP, (PRIM)PRQUOTE},
  966.         {":",           D_COMP, (PRIM)DEFINE},
  967.         {"DO",          D_INT,  (PRIM)DO},
  968.         {"UNTIL",       D_INT,  (PRIM)UNTIL},
  969.         {"WHILE",       D_INT,  (PRIM)WHILE},
  970.         {"BREAK",       D_INT,  (PRIM)BREAK},
  971.         {"CONTINUE",    D_INT,  (PRIM)CONTINUE},
  972.         {"IF",          D_INT,  (PRIM)DOIF},
  973.         {"ELSE",        D_INT,  (PRIM)DOELSE},
  974.         {"ENDIF",       D_INT,  (PRIM)ENDIF},
  975.         {"NOT",         D_INT,  (PRIM)NOT},
  976.         {"VARIABLE",    D_INT,  (PRIM)VARIABLE},
  977.         {"CONSTANT",    D_INT,  (PRIM)CONSTANT},
  978.         {"BUFFER",      D_INT,  (PRIM)BUFFER},
  979.         {"PUTCHAR",     D_INT,  (PRIM)PUTCHAR},
  980.         {"C.",          D_INT,  (PRIM)PUTCHAR},
  981.         {"I.",          D_INT,  (PRIM)PUTINT},
  982.         {".",           D_INT,  (PRIM)PUTINT},
  983.         {"U.",          D_INT,  (PRIM)UPUTINT},
  984.         {"GETCHAR",     D_INT,  (PRIM)GETCHAR},
  985.         {"GETINT",      D_INT,  (PRIM)GETINT},
  986.         {"GETSTR",      D_COMP, (PRIM)GETSTR},
  987.         {"SPACES",      D_INT,  (PRIM)SPACES},
  988.         {"NEWLINE",     D_INT,  (PRIM)NEWLINE},
  989.         {"TYPESTR",     D_INT,  (PRIM)TYPESTR},
  990.         {"LOADFILE",    D_INT,  (PRIM)LOADFILE},
  991.         {"EXIT",        D_INT,  (PRIM)DOEXIT},
  992.         {"FREEMEM",     D_INT,  (PRIM)FREEMEM},
  993.         {".DICT",       D_INT,  (PRIM)PRDICT},
  994.         {0,0,0}                                 /* end of dictionary */
  995. };
  996.  
  997.  
  998.